home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / TOOLKI.ARJ / TOOLS.PRG < prev   
Text File  |  1991-01-07  |  29KB  |  1,358 lines

  1. *****
  2. * first
  3. * returns the first atom of a list expression
  4. *****
  5.  
  6. FUNCTION first
  7. PARAMETER list
  8.  
  9. list = ALLTRIM(list)
  10.  
  11. sendBack = iif( " " $ list, substr(list,1,at(" ",list)-1), list)
  12.  
  13. return sendBack
  14.  
  15. *****
  16. * butfirst
  17. * returns all but the first atom of a list string expression
  18. *****
  19.  
  20. FUNCTION butfirst
  21. PARAMETER list
  22.  
  23. list = ALLTRIM(list)
  24.  
  25. sendback = iif( " " $ list, right(list,len(list)-at(" ",list)), "")
  26.  
  27. return alltrim(sendBack)
  28.  
  29. *****
  30. * tail
  31. * returns the last atom of a list string expression
  32. *****
  33.  
  34. FUNCTION tail
  35. PARAMETER list
  36.  
  37. list = ALLTRIM(list)
  38.  
  39. sendBack = iif( " " $ list, right(list,len(list)-rat(" ",list)), list)
  40.  
  41. return sendBack
  42.  
  43. *****
  44. * item
  45. * seeks <expN> atom in a list
  46. *****
  47.  
  48. function item
  49. parameters list,whichOne
  50.  
  51. for i = 1 to whichOne - 1
  52.     list = butfirst(list)
  53. next
  54.  
  55. return alltrim(first(list))
  56.  
  57. *****
  58. * atoms
  59. * returns the number of atoms in a list
  60. *****
  61.  
  62. function atoms
  63. parameters list
  64.  
  65. count = 0
  66.  
  67. do while .not. empty(list)
  68.     list = butfirst(list)
  69.     count = count + 1
  70. enddo
  71.  
  72. return count
  73.  
  74.  
  75. *****
  76. function depth
  77. *****
  78.  
  79. parameter namedArray,limit
  80. for i = 1 to limit
  81.     if empty(&namedArray(i))
  82.         exit
  83.     endif
  84. next
  85. return i-1
  86.  
  87. *****
  88. function military
  89. *****
  90.  
  91. *- takes a string variable of the form ##:##XX ie, 4:45pm, 5:30am
  92. *- and returns a string in military time, ie, 1645, 0530
  93.  
  94. parameter Time12
  95.  
  96. time24 = alltrim(str(val(left(Time12,2)) + ;
  97.          iif(right(Time12,2) = "am", 0, 12))) + ;
  98.          padl(alltrim(str((val(substr(Time12,4,2)) / 60) * 100)),2,"0")
  99.          
  100. if left(time24,2) = "12"
  101.     time24 = stuff(time24,1,2,"00")
  102. endif
  103. if left(time24,2) = "24"
  104.     time24 = stuff(time24,1,2,"12")
  105. endif
  106.  
  107. return Time24
  108.  
  109. *****
  110. function Odometer
  111. *****
  112.  
  113. parameters parm1, parm2, parm3, parm4,;
  114.            parm5, parm6, parm7, parm8, parm9, parm10
  115.  
  116. array = 0
  117. xLoc = 0
  118. yLoc = 0
  119. length = 0
  120.  
  121. pictString = ""
  122.  
  123. select i                            &&- We now need to open odometer.dbf
  124. use odometer                        &&- contains odometer table
  125. handle = 0                            &&- the handle of whichever odometer 
  126.                                     **- is being used
  127.  
  128.     */ Parsing of the message
  129.  
  130. parm1 = lower(parm1)                &&- put the message into lower case
  131.                                     **- for consistency
  132.  
  133. do case
  134.     case parm1 = "setup"
  135.         do setod                    &&- sets up odometer, returns handle
  136.     case parm1 = "roll"
  137.         do roll                        &&- rolls an odometer up or down
  138.     case parm1 = "add"
  139.         do add                        &&- adds a new entry to the array
  140.     case parm1 = "menu"
  141.         do menu                        &&- makes a cute little menu
  142.     case parm1 = "edit"
  143.         do edit                        &&- edits current entry
  144.     case parm1 = "close"
  145.         do close                    &&- closes odometer by handle
  146.     case parm1 = "delete"
  147.         do del                        &&- deletes current entry
  148.     case parm1 = "refresh"
  149.         do refreshHandle            &&- refreshes the odometer
  150. endcase
  151.  
  152. use                                    &&- closes the dbf
  153. return handle                        &&- handle of the odometer for
  154.                                     **- the calling program's reference
  155.  
  156. *****
  157. proc menu
  158. *****
  159.  
  160. handle = parm2                        &&- get the handle
  161. success = getHandle()                &&- get handle data
  162.     
  163. if arrayDepth <= 1                    &&- if array is too small
  164.     return                            &&- no sense making a menu!
  165. endif
  166.  
  167. **- define the menu and its bars
  168. define popup ArrayMenu from xloc,yloc    
  169. for i = 1 to arrayDepth
  170.     define bar i of arrayMenu prompt dtoc(&array(i))
  171. next
  172.  
  173. on selection popup arrayMenu deactivate popup arrayMenu
  174. activate popup arrayMenu
  175.  
  176. if .not. empty(prompt())
  177.     record = bar()                    &&- array element <record> chosen
  178.     replace recordNo with record    &&- select that element
  179. endif
  180. do fieldSay                            &&- put it on the screen
  181.  
  182. return    
  183.  
  184. *****
  185. proc refreshHandle
  186. *****
  187.  
  188. handle = parm2                        &&- get the handle
  189. success = getHandle()                &&- get handle data
  190.                                             
  191. do refreshOd
  192.  
  193. RETURN
  194.  
  195. *****
  196. procedure setod
  197. *****
  198.  
  199. array = parm2                        &&- isolate the name of the array
  200. xLoc = parm4                        &&- the row it wants to happen at
  201. yLoc = parm5                        &&- the column it wants to happen at
  202. maxEntries = parm7                    &&- the max number of entries
  203. length = parm9                        &&- the length of each entry
  204. pictString = parm10                    &&- picture string for entering
  205. if pictstring = .F.
  206.     pictstring = ""
  207. endif
  208. arrayDepth = depth(array,maxEntries) &&- discern the depth of the array
  209.     
  210. if arrayDepth > 0                    &&- if there's nothing in the
  211.     record = 1                        &&- array, we should let other
  212. else                                &&- parts of the program know
  213.     record = 0                        &&- so we set record to 0
  214. endif
  215.     
  216. if eof()                            &&- determine the handle number
  217.     handle = 1                        &&- to use.
  218. else
  219.     goto bottom
  220.     handle = dhandle + 1
  221. endif
  222.  
  223. */ create a descriptive entry in the odometer table
  224.  
  225. append blank
  226. replace ;
  227.     dhandle with handle, ;
  228.     arrayName with array, ;
  229.     xLocation with xloc, ;
  230.     yLocation with yloc, ;
  231.     recordNo with record, ;
  232.     Max with MaxEntries, ;
  233.     recordLen with length, ;
  234.     Depth with arrayDepth, ;
  235.     dbPict with pictString
  236.  
  237. do refreshOd
  238.  
  239. return 
  240.     
  241. *****
  242. proc refreshOd
  243. *****
  244.  
  245. */ Put the display box onscreen
  246.  
  247. @xLoc-1 ,yLoc-1 to xLoc + 1, yLoc + length    double        
  248.  
  249. */ put the entry on screen
  250.  
  251. do fieldSay
  252.  
  253. RETURN
  254.  
  255. *****
  256. procedure roll
  257. *****
  258.  
  259. command = parm2                        &&- find either "up" or "down"
  260. handle = parm3                        &&- get the handle we're working with
  261. success = getHandle()                &&- load our public variables with
  262.                                     &&- information found under the handle
  263.  
  264. if command = "up"
  265.     if record < max .and. ;
  266.     record < arrayDepth .and. ;
  267.     record > 0                            &&- if in an acceptable range & >0
  268.         record = record + 1                &&- move forward one
  269.         replace recordNo with record    &&- make sure our file is updated
  270.     else
  271.         do beepError                    &&- can't do that!
  272.     endif
  273. else
  274.     if command = "down"
  275.         if record > 1                    &&- if in an acceptable range
  276.             record = record - 1            &&- move back one
  277.             replace recordNo ;            
  278.             with record                    &&- update file
  279.         else
  280.             do beepError                &&- can't do that!
  281.         endif
  282.     else
  283.         do dunno with "understand commands to roll"
  284.     endif
  285. endif
  286.  
  287. */ update the screen
  288. do fieldSay
  289.  
  290. return
  291.  
  292. *****
  293. procedure edit
  294. *****
  295.  
  296. handle = parm2                            &&- get the handle
  297.  
  298. if record > 0                            &&- check for acceptable value
  299.     success = getHandle()                &&- get handle data
  300.     do fieldEdit                            
  301. else
  302.     do beepError                        &&- can't do it!
  303. endif
  304.  
  305. return
  306.     
  307. *****
  308. procedure add
  309. *****
  310.  
  311. handle = parm2                            &&- get the handle
  312.  
  313. success = getHandle()                    &&- get handle data
  314.  
  315. if arrayDepth < maxEntries                &&- make sure we're allowed 
  316.     arrayDepth = arrayDepth + 1            &&- to do this
  317.     record = arrayDepth                    &&- add the record
  318.     do fieldEdit                        &&- edit it
  319.     replace Depth with arrayDepth        &&- update the file!
  320.     replace RecordNo with record
  321. else
  322.     do beepError                        &&- can't do it!
  323. endif
  324.  
  325. return
  326.  
  327. *****
  328. procedure del
  329. *****
  330.  
  331. handle = parm2                                    &&- get our handle
  332.  
  333. success = getHandle()                            &&- get the handle data
  334.  
  335. if record > 0                                    &&- if there are records
  336.     if record # arrayDepth                        &&- if it's not the last one
  337.         &array(record) = &array(arrayDepth)        &&- last becomes the one
  338.         if type(array) = "C"
  339.             &array(arrayDepth) = ""                &&- we just deleted
  340.         else                                    &&- Oi! Date's assumed
  341.             &array(arraydepth) = {  /  /  }
  342.         endif
  343.         arrayDepth = arrayDepth - 1                &&- delete it and
  344.         replace depth with arrayDepth            &&- update the file
  345.     else    
  346.         if type(array) = "C"
  347.             &array(arrayDepth) = ""            &&- if it is the last one
  348.         else                                &&- (Oi! Date's assumed)
  349.             &array(arraydepth) = {  /  /  }
  350.         endif
  351.         arrayDepth = arrayDepth - 1            &&- just delete it and
  352.         record = record - 1                    &&- update our data and file
  353.         replace depth with arrayDepth
  354.         replace recordNo with record
  355.     endif
  356. else
  357.     do beepError                                &&- can't do it
  358. endif
  359.  
  360. do fieldSay
  361.  
  362. return
  363.  
  364. *****
  365. procedure close
  366. *****
  367.  
  368. handle = parm2
  369.  
  370. success = getHandle()
  371.  
  372. @xLoc-1 ,yLoc-1 clear to xLoc + 1, yLoc + length    &&- clear the odometer
  373.  
  374. use odometer exclusive                        &&- clear out odometer.dbf
  375. delete record recno()
  376. pack
  377. use odometer
  378. return    
  379.  
  380. *****
  381. procedure fieldEdit
  382. *****
  383.  
  384. select g                                            &&- empty workspace
  385.  
  386. if type(array) = "C"                        &&- if it's character data
  387.     tempSpace = space(length)                &&- get it and read it
  388.     @xLoc,yLoc GET tempSpace picture pictString
  389.     READ
  390. else                                         &&- Oi! we're assuming date!
  391.     tempSpace = {  /  /  }                    &&- don't let a date which
  392.                                             &&- predates today be entered
  393. *    @xLoc,yLoc GET tempSpace valid tempSpace > date() - 7
  394.     @xLoc,yLoc GET tempSpace
  395.     READ
  396. endif
  397.  
  398. for doIt = 1 to arrayDepth                    &&- do not permit duplicates
  399.     if &array(doIt) = tempSpace .and. doIt <> record
  400.         do dunno with "Allow you to enter duplicate fields!"
  401.         do fieldedit
  402.         return
  403.     endif
  404. next
  405.  
  406. &array(record) = tempSpace
  407.  
  408. do fieldSay
  409.  
  410. select i                                &&- odometer's workspace
  411.                                     
  412. return
  413.  
  414. *****
  415. procedure fieldSay
  416. *****
  417. **- put the field in the odometer box
  418.  
  419. if record > 0
  420.     if type(array) = "C"
  421.         @xloc,yloc say left(&array[record],length)
  422.     else
  423.         @xloc, yloc say &array[record]
  424.     endif
  425. else
  426.     @xloc,yloc say space(length)
  427. endif
  428.  
  429. return
  430.  
  431. *****
  432. function getHandle
  433. *****
  434.  
  435. **- retrieve the data associated with the handle
  436.  
  437. locate for dhandle = handle
  438. if .not. found()
  439.     do dunno with "know where to find your handle"
  440.     cancel
  441. endif
  442.  
  443.     array = arrayName
  444.     xLoc = xLocation
  445.     yLoc = yLocation
  446.     record = recordNo
  447.     maxEntries = max
  448.     length = recordLen
  449.     arrayDepth = Depth
  450.     pictString = dbPict
  451.     
  452. return .t.
  453.  
  454. *****
  455. * ALERT
  456. * Creates a dialogue box w/buttons
  457. * ALERT returns either 1, 2, or 3   
  458. *****
  459.  
  460. function alert
  461. parameters form,first,second,third,question1,question2,question3
  462.  
  463. form = lower(form)
  464.         
  465. DEFINE WINDOW answerWindow ;
  466. FROM 8,15 TO 17,65    float DOUBLE color scheme 14        &&Make the window
  467.  
  468. **- define ANSWERMENU and its pads
  469. DEFINE MENU answerMenu color scheme 14
  470.  
  471. IF lower(first)<>"null"
  472.     first = prButton(first)
  473.     DEFINE PAD a OF answerMenu ;
  474.     PROMPT first AT 7,1
  475.     ON SELECTION PAD a OF answerMenu ;
  476.     DEACTIVATE MENU answerMenu
  477. ENDIF
  478.  
  479. IF lower(second)<>"null"
  480.     second= prButton(second)
  481.     DEFINE PAD b OF answerMenu ;
  482.     PROMPT second AT 7,16
  483.     ON SELECTION PAD b OF answerMenu ;
  484.     DEACTIVATE MENU answerMenu
  485. ENDIF
  486.  
  487. IF lower(third)<>"null"
  488.     third= prButton(third)
  489.     DEFINE PAD c OF answerMenu ;
  490.     PROMPT third AT 7,32
  491.     ON SELECTION PAD c OF answerMenu ;
  492.     DEACTIVATE MENU answerMenu
  493. ENDIF
  494.  
  495. ACTIVATE WINDOW answerWindow                 &&Open the window
  496.  
  497. do ikon with form,0,0                        &&- display the chosen icon
  498.  
  499. if .not. empty(question1)
  500.     @ 1,10 say question1    
  501. endif
  502.  
  503. if .not. empty(question2)
  504.     @ 2,10 say question2
  505. endif
  506.  
  507. if .not. empty(question3)
  508.     @ 3,10 say question3    
  509. endif
  510.  
  511. fini = 0             
  512. do while fini = 0        
  513.     ACTIVATE MENU answerMenu             &&Turn on the menu
  514.     if .not. empty(pad())
  515.         fini = 1
  516.     endif
  517. enddo
  518.  
  519. DEACTIVATE WINDOW answerWindow                &&Clear the window
  520. RELEASE WINDOW answerWindow
  521. RELEASE MENU answermenu
  522.  
  523. return asc(pad()) - 64
  524.  
  525. *****
  526. function prButton
  527. *****
  528.  
  529. parameters string
  530.  
  531.     string = LEFT(string,10)
  532.     string = padc(string,10)
  533.     string = "<" + string + ">"
  534.     
  535. return string
  536.  
  537. *****
  538. proc ikon
  539. *****
  540.  
  541. parameters icon, x, y
  542.  
  543. do case
  544. case icon = "wait"
  545.     @x+1,y+3 say "█"
  546.     @x+2,y+3 say "█"
  547.     @x+3,y+3 say "█"
  548.     @x+4,y+3 say "▄"
  549. case icon = "dialogue"
  550.     @x+0,y+1 say "┌───┐"
  551.     @x+1,y+1 say "│  └┐"
  552.     @x+2,y+1 say "│   ┌┘"
  553.     @x+3,y+1 say "│  ┌┘"
  554.     @x+4,y+1 say "│  └┐"
  555.     @x+5,y+1 say "└───┘"
  556. case icon = "unhappy"
  557.     @x+0,y+1 say "┌───┐"
  558.     @x+1,y+1 say "│  └┐"
  559.     @x+2,y+1 say "│   ┌┘"
  560.     @x+3,y+1 say "│ ┌─┤"
  561.     @x+4,y+1 say "│   │"
  562.     @x+5,y+1 say "└───┘"
  563. case icon = "happy"
  564.     @x+0,y+1 say "┌───┐"
  565.     @x+1,y+1 say "│  └┐"
  566.     @x+2,y+1 say "│   ┌┘"
  567.     @x+3,y+1 say "│ └─┤"
  568.     @x+4,y+1 say "│   │"
  569.     @x+5,y+1 say "└───┘"
  570. case icon = "question"
  571.     @x+1,y+1 say "  ┌───┐"
  572.     @x+2,y+1 say "│ │ ? │"
  573.     @x+3,y+1 say "└─┼───┘"
  574.       @x+4,y+1 say "  └───" 
  575. endcase
  576.  
  577. return
  578.  
  579. *****
  580. procedure explode
  581. *****
  582.  
  583. parameters startx,starty,endx,endy,endheight,endwidth
  584.  
  585. for i = 1 to 100 step 10
  586.         percent = i * .01
  587.         y = starty + ((endy - starty) * percent)
  588.         x = startx + ((endx - startx) * percent) 
  589.         define window stretch from x,y to ;
  590.         x+ceiling(endheight*percent),;
  591.         y+ceiling(endwidth*percent) 
  592.         show window stretch
  593.         hide window stretch
  594. next
  595.  
  596. release window stretch
  597.  
  598. return
  599.  
  600. *****
  601. proc tedit
  602. * Creates a dialogue box
  603. * Syntax
  604. * "title justification prompt|variable|picture ..."
  605. *    title -         should be the name of a string variable which 
  606. *                    contains the title string. It should be no more than 90 
  607. *                    chars long.
  608. *    justification-     centered, left, or right: for the variable's say/get
  609. *    prompt-            the name of a string variable containing the prompt
  610. *                    for the following variable
  611. *    variable-        the name of the string variable you want to store
  612. *                    data in. should be initialized to the length you
  613. *                    want.
  614. *    picture-        a picture string, such as XXXXX. As of now, it should
  615. *                    contain no spaces. Spaces can be replaced with an X
  616. *
  617. *    You can include as many prompt|variable|picture combinations as
  618. *    screen space will allow!
  619. *****
  620.  
  621. PARAMETERS message
  622. message = lower(message)                    &&- put it in lowercase
  623.  
  624.  
  625. numOfFields = atoms(message) - 2            &&- number of fields
  626.  
  627. question = first(message)                    &&- title for query box
  628.  
  629. question = &question                        &&- macro de-embedding
  630.  
  631. DEFINE WINDOW answerWindow ;
  632. FROM 10,15 TO 14 + numOfFields,63 DOUBLE ;
  633. COLOR SCHEME 15                                &&- Make the window
  634.  
  635. ACTIVATE WINDOW answerWindow                &&Open the window
  636.  
  637. do divq with question,46
  638.  
  639. for askem = 1 to numOfFields                &&- do for each field
  640.     variable = item(message,askem+2)        &&- get the data
  641.     
  642.     firstDelim = at("|",variable)            &&- find first |
  643.     secondDelim  = rat("|",variable)        &&- find second |
  644.     
  645.     prompt = left(variable,firstDelim-1)    &&- what to say
  646.     
  647.     pictstr = right(variable,len(variable) - secondDelim)
  648.     if pictstr = "none" 
  649.         pictstr = ""
  650.     endif
  651.     
  652.                     */ get the variable name /*
  653.     
  654.     macroVar = substr(variable,firstDelim+1,secondDelim-firstDelim-1)
  655.     
  656.     just = first(butfirst(message))            &&- determine the 
  657.     do case                                    &&- justification
  658.         case just = "right"
  659.             getAt = 47-len(&prompt+¯oVar)
  660.         case just = "left"
  661.             getAt = 1
  662.         case just = "center"
  663.             getAt = 23-len(&prompt+¯oVar)/2
  664.     endcase
  665.     @1+askem,getAt say &prompt get ¯ovar picture pictstr
  666. next
  667. read
  668.  
  669. DEACTIVATE WINDOW answerWindow                &&Clear the window
  670. RELEASE WINDOW answerWindow
  671.  
  672. *****
  673. function getTime
  674. *****
  675.  
  676. parameters xLocation,yLocation
  677.  
  678. timeToGet = "       "
  679. @xLocation,yLocation ;
  680. get timeToGet picture "##:##!!" valid timetest(timeToGet)
  681. read
  682. timetoGet = lower(timeToGet)
  683.  
  684. **- align the hours and/or clear up any leading zeroes
  685. timeToGet = padl( alltrim( str( val( left( timeToGet,2)))), 2) + ;
  686.             right( timeToGet, 5)
  687. @xlocation, ylocation say timeToGet
  688. return timeToGet
  689.  
  690. *****
  691. function timetest
  692. *****
  693. parameter timeToTest
  694. hours = val(left(timeToTest,2))
  695. if .not. between(hours,1,12)
  696.     return .f.
  697. endif
  698.  
  699. minute = val(substr(timeToTest,4,2))
  700. if .not. between(minute,0,45) 
  701.     return .f.
  702. endif
  703.  
  704. if .not. mod(minute,15)  = 0
  705.     return .f.
  706. endif
  707.  
  708. ampm = right(timeToTest,2)
  709. if .not. (ampm = "AM" .or. ampm = "PM")
  710.     return .f.
  711. endif
  712.  
  713. return .t.
  714.  
  715. *****
  716. function tick
  717. *****
  718.  
  719. PARAMETERS row,column,tickedString
  720.  
  721. *Expecting Mprompts to be an array equal in elements to the length 
  722. *of tickedString
  723.  
  724. DEFINE POPUP tickEr FROM row,column color scheme 12
  725.  
  726. FOR iteration = 1 TO LEN(tickedString)
  727.  
  728.     flag = substr(tickedString,iteration,1)
  729.     if flag = "0"
  730.         thisPrompt= "  " + Mprompts(iteration)
  731.         DEFINE BAR iteration OF tickEr ;
  732.         PROMPT thisPrompt SKIP
  733.     else
  734.         thisPrompt=flag + " " + Mprompts(iteration)
  735.         DEFINE BAR iteration OF tickEr ;
  736.         PROMPT thisPrompt             
  737.     endif
  738.     
  739. NEXT
  740.  
  741. ON SELECTION POPUP tickEr DO tickEt
  742.  
  743. ACTIVATE POPUP tickEr
  744.  
  745. release popup tickEr
  746.  
  747. RETURN tickedString
  748.  
  749. *****
  750. * PROCEDURE tickET
  751. * ticks a spot on the popup, and resets the string variable
  752. *****
  753.  
  754. PROCEDURE tickET
  755.  
  756. IF SUBSTR(tickedString,BAR(),1)="√"
  757.     tickedString=LEFT(tickedString,BAR()-1)+" "+SUBSTR(tickedString,BAR()+1)
  758. ELSE
  759.     tickedString=LEFT(tickedString,BAR()-1)+"√"+SUBSTR(tickedString,BAR()+1)
  760. ENDIF
  761. deactivate POPUP tickEr
  762.  
  763. RETURN
  764.  
  765. *****
  766. function inrange
  767. *- determines if the two time ranges expressed in the parameters overlap
  768. *- parameters must be 24 hour times in format "0845" or "1245"
  769. *****
  770.  
  771. parameters first,second,third,fourth
  772.  
  773. second = iif(second < first, second + 2400, second)
  774. fourth = iif(fourth < third, fourth + 2400, fourth)
  775.  
  776. if between(first,third,fourth) ;
  777. .or. between(second,third,fourth) ;
  778. .or. between(third,first,second) ;
  779. .or. between(fourth,first,second)
  780.     result = .t.
  781. else
  782.     result = .f.
  783. endif
  784.  
  785. return result
  786.  
  787. *****
  788. proc chooser
  789. *****
  790.  
  791. do objects
  792.     
  793. acti window chooser
  794. do printerIkon
  795.  
  796. acti menu chooser pad &chosenPrin
  797.  
  798. release window chooser
  799.  
  800. *****
  801. proc choose
  802. *****
  803.  
  804. chosenPrinter = upper(pad())
  805. do case
  806. case chosenPrinter = "DOTMATRIX"
  807.     set printer to \\lpt1\p=0
  808. case chosenPrinter = "LASER"
  809.     set printer to \\lpt1\p=2
  810. case chosenPrinter = "LOCAL"
  811.     !endcap > nul
  812. endcase
  813. do printerIkon
  814.  
  815. RETURN
  816.  
  817. *****
  818. proc objects
  819. *****
  820.  
  821. *- defines objects such as menus and windows
  822.  
  823. *- window for chooser
  824. define window chooser from 5,20 to 15,60 title "Oat Bran Chooser" color scheme 17
  825.  
  826. *- menu to choose printer
  827. define menu chooser color scheme 17
  828.  
  829. define pad DotMatrix of  chooser at 1,3 prompt "Dot Matrix" color scheme 17
  830. on selection pad DotMatrix of chooser do choose
  831.  
  832. define pad Laser of  chooser at 3,3 prompt "Laser" color scheme 17
  833. on selection pad laser of chooser do choose
  834.  
  835. define pad local of chooser at 5,3 prompt "Local" color scheme 17
  836. on selection pad local of chooser do choose
  837.  
  838. define pad finished of chooser at 7,3 prompt "Finished" color scheme 17
  839. on selection pad finished of chooser deactivate menu
  840. RETURN
  841.  
  842. *****
  843. proc printerIkon
  844. *****
  845.  
  846. @2,20 say "    ┌─────┐"
  847. @3,20 say "    │LPT1:│" 
  848. @4,20 say "┌───▀▀▀▀▀▀▀───┐ ╦"
  849. @5,20 say "│         ■■■■│ ║"
  850. @6,20 say "│ " + padc(chosenPrinter,11) + " ╞═╝"
  851. @7,20 say "└─────────────┘"
  852.  
  853. RETURN
  854.  
  855. *****
  856. proc printSetup
  857. *- sets up the chosen Printer
  858. *****
  859.  
  860. do case
  861. case chosenPrinter = "DOTMATRIX"
  862.     do epsonOptions
  863. case chosenPrinter = "LASER"
  864.     do laserOptions
  865. case chosenPrinter = "POSTSCRIPT"
  866.     * Yeah, right
  867. endcase
  868.  
  869.     ***
  870.     proc epsonOptions
  871.     *- sets up the epson printer
  872.     ***
  873.     
  874.     chosen = alert ("dialogue", "Underline", "Bold", "Normal", "Style?")
  875.     
  876.     do case
  877.     case chosen = 1
  878.         do send with chr(27) + chr(45) + chr(1)
  879.     case chosen = 2
  880.         do send with chr(27) + chr(69)
  881.     case chosen = 3
  882.         do send with chr(27) + chr(70) + chr(27) + chr(45) + chr(0)
  883.     endcase
  884.  
  885. return
  886.     
  887.         ***
  888.         proc send
  889.         *- sends something to the printer
  890.         ***
  891.         
  892.         parameters controlString
  893.         
  894.         set print on
  895.         set console off
  896.         ?? controlString
  897.         set print off
  898.         set console on
  899.         
  900.         return
  901.  
  902. *****
  903. proc userlist
  904. *****
  905.  
  906. save screen
  907. define window users from 10,15 to 24,68 title "Userlist" ;
  908. system close float color scheme 8
  909. wait "Please hold on..." Window timeout .5
  910. fileName = "i:" + sys(3)
  911. @ 0,0
  912. !userlist > &fileName
  913. acti screen
  914. restore screen
  915. modi file (filename) window users noedit
  916. erase (fileName)
  917.  
  918. *****
  919. proc openProgram
  920. *****
  921. parameters progName
  922.  
  923. @0,0 fill to 0,79 color n/w
  924. @0,0 say padc(progName,79) color n/w
  925. do explode with 12,40,0,0,24,79
  926. activate screen                    &&- just in case some windows are around
  927. clear                                    
  928.  
  929. RETURN
  930.  
  931. *****
  932. proc systemMenu
  933. *****
  934.  
  935. acti Popup SystemMenu
  936.  
  937. do case
  938. case bar() = 1                    
  939.     *- about
  940.     set compatible foxplus
  941.     workArea = str(select())
  942.     
  943.     select 19
  944.     use register
  945.     modify memo about window about noedit nowait
  946.     do while empty(inkey())
  947.     enddo
  948.     close memo about
  949.     use
  950.     
  951.     select &workarea
  952.     
  953. case bar() = 2
  954.     help
  955. case bar() = 4
  956.     do chooser
  957. case bar() = 5
  958.     do userlist
  959. endcase
  960.  
  961. RETURN    
  962.  
  963. *****
  964. procedure shrink
  965. *****
  966.  
  967. parameters startx,starty,endx,endy,endheight,endwidth
  968.  
  969. for i = 100 to 1 step -10
  970.         percent = i * .01
  971.         y = starty + ((endy - starty) * percent)
  972.         x = startx + ((endx - startx) * percent) 
  973.         define window stretch from x,y to ;
  974.         x+ceiling(endheight*percent),;
  975.         y+ceiling(endwidth*percent) 
  976.         show window stretch
  977.         hide window stretch
  978. next
  979.  
  980. release window stretch
  981.  
  982. return
  983.  
  984. *****
  985. proc divQ
  986. *****
  987.  
  988. parameters question, length
  989.  
  990. qLength = len(question)
  991.  
  992. if qLength > length
  993.     if mod(qLength,2) # 0
  994.         question = question + " "
  995.         qLength = qLength + 1
  996.     endif
  997.     searchArea = substr(question,qLength/2,length/2)
  998.     whereSpace = at(" ",searchArea) + qLength/2 -1
  999.     question1 = left(question, wherespace-1)
  1000.     question2 = right(question,qLength-whereSpace) 
  1001.     @0,0 say padc(alltrim(question1),length)
  1002.     @1,0 say padc(alltrim(question2),length)
  1003. else
  1004.     @0,0 say padc(question,length)
  1005. endif
  1006.  
  1007. return
  1008.  
  1009. *****
  1010. proc beepError
  1011. *****
  1012.  
  1013. @0,0 fill to 0,79 color w/n
  1014. for i = 1 to 200
  1015. next
  1016. wait window "Yo!" timeout .001
  1017. @0,0 fill to 0,79 color n/w
  1018.  
  1019. *****
  1020. * Yo
  1021. * Creates a dialogue box
  1022. * Very important that passed parameters meet syntax!
  1023. *****
  1024.  
  1025. function Yo
  1026. parameters form,delayLength,question1,question2,question3
  1027.  
  1028. form = lower(form)
  1029.         
  1030. DEFINE WINDOW answerWindow ;
  1031. FROM 8,15 TO 17,65    float DOUBLE color scheme 8        &&Make the window
  1032.  
  1033. *do explode with 12,40,8,15,9,50
  1034. ACTIVATE WINDOW answerWindow                 &&Open the window
  1035.  
  1036. do ikon with form,0,0
  1037.  
  1038. if .not. empty(question1)
  1039.     @ 1,10 say question1    
  1040. endif
  1041.  
  1042. if .not. empty(question2)
  1043.     @ 2,10 say question2
  1044. endif
  1045.  
  1046. if .not. empty(question3)
  1047.     @ 3,10 say question3    
  1048. endif
  1049.  
  1050. = inkey(delayLength)
  1051.  
  1052. DEACTIVATE WINDOW answerWindow                &&Clear the window
  1053. RELEASE WINDOW answerWindow
  1054.  
  1055. return .t.
  1056.  
  1057. *****
  1058. function card
  1059. *****
  1060.  
  1061. *- card permits us to set up a screen o' buttons from a definition file */
  1062. *- Variables:
  1063. *-        message:        Sent from calling program. Used as return variable
  1064. *-                        when telling the caller that success was obtained.
  1065. *-        databaseName:    Public. Contains the name of the database which
  1066. *-                        is being used by card.
  1067. *-        buttons[x,x]:    Public. Array containing button information where:
  1068. *-                        buttons[x,1] is the row of the button 
  1069. *-                        buttons[x,2] is the left column
  1070. *-                        buttons[x,3] is the right column    
  1071. *-                        buttons[x,4] is the enable/disable flag
  1072. *-                        buttons[x,5] is the button name
  1073. *-         buttonLimit:    Public. Number of buttons found in the database
  1074. *-        counter:        A loop control variable. Counts through numbered
  1075. *-                        buttons designated by buttonLimit
  1076. *-        disabled:        Found in check() If true, then check will ignore
  1077. *-                        option disabling. If false, then check will ignore
  1078. *-                        any button which is shut off
  1079. *-        clicked:        simply a variable which allows us to call inkey
  1080. *-        hit:            the number of the button which was hit
  1081. *-        buttonToDisable:the number of the button to be disabled
  1082. *-        buttonToEnable: the number of the button to enable
  1083. *-
  1084. *-    Syntax of commands:
  1085. *-  x = card("setup <expc>") 
  1086. *-        initializes and displays a card which is configured in 
  1087. *-        the database named <expc>
  1088. *-    hit = card("check [disabled]")
  1089. *-        checks the mouse for a button hit. the disabled option ignores
  1090. *-        button disabling.
  1091. *-    x = card("disable <expn>")
  1092. *-        disables button number <expn>
  1093. *-  x = card("enable <expn>")
  1094. *-        enables button number <expn>. Buttons default to enabled status.
  1095. *- in order for card to work, procedure must be set to PARSE
  1096.  
  1097. parameters message
  1098. message = lower(message)
  1099. *- message is the command sent to CARD
  1100. *- Parse it in lowercase for uniformity
  1101.  
  1102. firstone = first(message)
  1103.  
  1104. do case
  1105.  
  1106.     case firstone = "setup"
  1107.         do doCard
  1108.         
  1109.     case firstone = "check"
  1110.         message = check()
  1111.         if message # 0 .and. message # 255
  1112.             do flash
  1113.         endif
  1114.         
  1115.     case firstone = "disable"
  1116.         do disable
  1117.         
  1118.     case firstone = "enable"
  1119.         do enable
  1120.                 
  1121.     case firstOne = "close"
  1122.         release buttons, buttonLimit
  1123.         
  1124.     case firstOne = "refresh"
  1125.         do refresh
  1126.                 
  1127. endcase
  1128. select j
  1129. use
  1130.  
  1131. return message
  1132.  
  1133. *****
  1134. procedure doCard
  1135. *****
  1136.  
  1137. */ butfirst(message) better equal the name of a configuration dbf    */
  1138. */ or this will send back an error message                        */    
  1139.  
  1140. databaseName = butfirst(message)
  1141.  
  1142. if file(databaseName + ".dbf")
  1143.     select j
  1144.     use (databaseName)
  1145.     do checkDatabase
  1146. else
  1147.     do dunno with "know where to find your database named " + databaseName
  1148.     message = .f.
  1149. endif
  1150.  
  1151. return message
  1152.  
  1153. *****
  1154. procedure checkDatabase
  1155. *****
  1156.  
  1157. */ this will check to see if the database if a proper configuration one */
  1158.  
  1159. if .not. ;
  1160. (field(1) = "ROW" .AND. ;
  1161. field(2) = "COLUMN" .AND. ;
  1162. field(3) = "BUTTON")
  1163.     do dunno with  "think that " + databaseName + " is a proper configuration file"
  1164.     message = .f.
  1165. else
  1166.     do prepare
  1167.     do refresh
  1168. endif
  1169. return    message
  1170.     
  1171. *****
  1172. procedure prepare
  1173. *****
  1174.  
  1175. release buttonLimit
  1176. release buttons
  1177. public buttons
  1178. public buttonlimit
  1179. buttonLimit = reccount()
  1180.  
  1181. dimension buttons[buttonLimit,5]
  1182.  
  1183. for counter = 1 to buttonLimit
  1184.  
  1185.     goto counter
  1186.  
  1187. */ now store it in memory */
  1188.  
  1189.     buttons[counter,1] = row                    &&- row location
  1190.     buttons[counter,2] = column                    &&- left column
  1191.     
  1192.     buttonLength = len(allTrim(button))            &&- length of button helps
  1193.     buttons[counter,3]=column+buttonLength-1    &&- us determine right column
  1194.     
  1195.     buttons[counter,4] = .T.                    &&- This is the enable
  1196.     buttons[counter,5] = alltrim(button)        &&- This is the buttonname
  1197.     
  1198. next (counter = 1 to buttonLimit)
  1199.  
  1200. message = .t.
  1201.  
  1202. select j
  1203. use
  1204. return
  1205.     
  1206.     ***
  1207.     function check
  1208.     ***
  1209.  
  1210.     if butfirst(message) = "disabled"        &&- checks for disabled items
  1211.         disabled = .t.
  1212.     else
  1213.         disabled = .f.
  1214.     endif
  1215.  
  1216.     clicked = 666
  1217.     */ let's wait for a mouse click */
  1218.     do while clicked <> 151 .and. .not. between(clicked,1,26)
  1219.         clicked = inkey("M")
  1220.     enddo
  1221.  
  1222.     row = mrow()                            &&- Store row and column of mouse pointer
  1223.     col = mcol()
  1224.  
  1225.     */ let's see if it's a doubleClick */
  1226.  
  1227.     clicked = inkey(.25, "M")
  1228.  
  1229.     if clicked <> 0
  1230.         dblClick = -1
  1231.     else
  1232.         dblClick = 1
  1233.     endif
  1234.  
  1235.     for counter = 1 to buttonLimit            &&- From first button to the last
  1236.         if row=buttons[counter,1] ;
  1237.         .and. ;
  1238.         between(col,buttons[counter,2],buttons[counter,3]) ;
  1239.         .and. ;
  1240.         (buttons[counter,4] .or. disabled)
  1241.           exit
  1242.        endif
  1243.     next
  1244.  
  1245.     if counter > buttonLimit
  1246.         counter = 0
  1247.     endif
  1248.  
  1249.     return counter*dblClick
  1250.  
  1251.     ***
  1252.     procedure refresh
  1253.     ***
  1254.  
  1255.     for counter = 1 to buttonLimit
  1256.  
  1257.     */ display it on the screen */
  1258.     
  1259.         do sayAButton with counter    
  1260.     
  1261.     next (counter = 1 to buttonLimit)
  1262.  
  1263.     return
  1264.     
  1265.     ***
  1266.     procedure disable
  1267.     ***
  1268.     
  1269.     firstButton = first(butfirst(message))
  1270.  
  1271.     if .not. type(firstbutton) = "N"
  1272.         if butfirst(message) = "all"
  1273.             FirstButton = 1
  1274.             lastButton = buttonLimit
  1275.         else
  1276.             do dunno with "understand alpha commands to disable"
  1277.         endif
  1278.     else
  1279.         firstButton = abs(val(firstButton))
  1280.         if .not. empty(tail(message))
  1281.             lastbutton = abs(val(tail(message)))
  1282.         else
  1283.             lastButton = firstButton
  1284.         endif
  1285.     endif
  1286.     
  1287.     for i = firstButton to LastButton
  1288.         buttons[i,4] = .F.
  1289.         do sayAButton with i
  1290.     next
  1291.  
  1292.     return 
  1293.  
  1294.     ***
  1295.     procedure enable
  1296.     ***
  1297.  
  1298.     firstButton = first(butfirst(message))
  1299.  
  1300.     if .not. type(firstbutton) = "N"
  1301.         if butfirst(message) = "all"
  1302.             FirstButton = 1
  1303.             lastButton = buttonLimit
  1304.         else
  1305.             do dunno with "understand alpha commands to disable"
  1306.         endif
  1307.     else
  1308.         firstButton = abs(val(firstButton))
  1309.         if .not. empty(tail(message))
  1310.             lastbutton = abs(val(tail(message)))
  1311.         else
  1312.             lastButton = firstButton
  1313.         endif
  1314.     endif
  1315.     
  1316.     for i = firstButton to LastButton
  1317.         buttons[i,4] = .T.
  1318.         do sayAButton with i
  1319.     next
  1320.  
  1321.     return 
  1322.  
  1323.     ***
  1324.     proc flash
  1325.     ***
  1326.  
  1327.     But = abs(message)
  1328.     @buttons(but,1), buttons(but,2) ;
  1329.     fill to buttons(but,1), buttons(but,3) color n/w*
  1330.  
  1331.     if buttons[but,1] = 0
  1332.         @buttons(but,1), buttons(but,2) ;
  1333.         fill to buttons(but,1), buttons(but,3) color n/w
  1334.     else
  1335.         @buttons(but,1), buttons(but,2) ;
  1336.         fill to buttons(but,1), buttons(but,3) color gr+/b
  1337.     endif
  1338.  
  1339.     return
  1340.  
  1341.     ***
  1342.     proc sayAButton
  1343.     ***
  1344.  
  1345.     parameter buttonToSay
  1346.  
  1347.     do case
  1348.     case buttons[buttonToSay,4] = .F.            &&- disabled
  1349.         @buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
  1350.         buttons[buttonToSay,5] color n+/b
  1351.     case buttons[buttonToSay,1] = 0                &&- if it's in the top row,
  1352.         @buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
  1353.         buttons[buttonToSay,5] color n/w        &&- it's part of the system menu
  1354.     otherwise
  1355.         @buttons[buttonToSay,1],buttons[buttonToSay,2] say ;
  1356.         buttons[buttonToSay,5] color gr+/b        &&- normal color
  1357.     endcase